home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istgi / ISTGI.MAC.f
Encoding:
Text File  |  1989-03-04  |  6.0 KB  |  181 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.4
  6. C---------------------------------------------------------
  7. C---------------------------------------------------------
  8. C    TOOLPACK/1    Release: 2.4
  9. C---------------------------------------------------------
  10. C---------------------------------------------------------
  11. C    TOOLPACK/1    Release: 2.4
  12. C---------------------------------------------------------
  13.  
  14.  
  15.  
  16.  
  17.  
  18.  
  19.  
  20.  
  21. C                                   parameter length
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  32.         PROGRAM ISTGI
  33.  
  34.         INTEGER IODSYI,IODSYO,SYIPTH(81),SYOPTH(81),PROMPT(22,2),
  35.      +          JUNK
  36.  
  37.         INTEGER GETARG,OPEN,CREATE,ZGTCMD
  38.         EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZGTCMD,ZYSOUT,ZINIT,ZQUIT,
  39.      +           ZMESS,ERROR
  40.  
  41.         DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
  42.      +121,109,98,111,108,32,116,97,98,108,101,58,
  43.      +32,129/,
  44.      +       (PROMPT(I,2),I=1,22)/79,117,116,112,117,116,32,
  45.      +115,121,109,98,111,108,32,116,97,98,108,101,58,
  46.      +32,129/
  47.  
  48.         CALL ZINIT
  49.  
  50.         IF (GETARG(1,SYIPTH,81).EQ.-100) THEN
  51.             CALL ZPRMPT(PROMPT(1,1))
  52.             JUNK=ZGTCMD(SYIPTH,0)
  53.         END IF
  54.         IF (GETARG(2,SYOPTH,81).EQ.-100) THEN
  55.             CALL ZPRMPT(PROMPT(1,2))
  56.             JUNK=ZGTCMD(SYOPTH,0)
  57.         END IF
  58.  
  59.         IODSYI=OPEN(SYIPTH,0)
  60.         IF (IODSYI.EQ.-1) CALL ERROR('Can''t open input symbol table')
  61.         IODSYO=CREATE(SYOPTH,1)
  62.         IF (IODSYO.EQ.-1) CALL ERROR('Can''t create o/p symbol table')
  63.  
  64.         CALL ZYINSY(IODSYI)
  65.  
  66.         CALL PROFIL
  67.  
  68.         CALL ZYSOUT(IODSYO)
  69.         CALL ZMESS('[ISTGI Normal Termination]',1)
  70.         CALL ZQUIT(-2)
  71.  
  72.         END
  73. C ----------------------------------------------------------------------
  74. C
  75. C       P R O F I L   -   Process file
  76. C
  77.  
  78.         SUBROUTINE PROFIL
  79.  
  80.         INTEGER NCONVS
  81.         PARAMETER (NCONVS=44)
  82.  
  83.         INTEGER SYMBOL(8),SYMPTR,BITS,TEXT(134),STRPTR,
  84.      +          N,RESULT(8),IFTYPE(NCONVS),TEXT2(134)
  85.         CHARACTER*6 SYMNAM,IFNAME(2,NCONVS)
  86.         LOGICAL CHANGE
  87.  
  88.         INTEGER ZYGNSY,ZIAND,ZYASTR,ZYFSYM,ZYGPUS
  89.         EXTERNAL ZYGNSY,ZIAND,ZYSATT,ZYASTR,PUTLIN,ZMESS,ZYGTST,ZITOF,
  90.      +           ZFTOI,ZYFSYM,ZSTRIP,ZYGPUS,ZYGTSY
  91.  
  92.         DATA IFNAME/'DSINH','SINH','DCOSH','COSH','DTANH','TANH',
  93.      +'IFIX','INT','IDINT','INT','FLOAT','REAL','SNGL','REAL',
  94.      +'DINT','AINT','DNINT','ANINT','IDNINT','NINT','IABS','ABS',
  95.      +'DABS','ABS','CABS','ABS','AMOD','MOD','DMOD','MOD',
  96.      +'ISIGN','SIGN','DSIGN','SIGN','IDIM','DIM','DDIM','DIM',
  97.      +'MAX0','MAX','AMAX1','MAX','DMAX1','MAX','MIN0','MIN',
  98.      +'AMIN1','MIN','DMIN1','MIN','DSQRT','SQRT','CSQRT','SQRT',
  99.      +'ALOG10','LOG10','DLOG10','LOG10','DEXP','EXP','CEXP','EXP',
  100.      +'ALOG','LOG','DLOG','LOG','CLOG','LOG','DSIN','SIN','CSIN','SIN',
  101.      +'DCOS','COS','CCOS','COS','DTAN','TAN','DASIN','ASIN',
  102.      +'DACOS','ACOS','DATAN','ATAN','DATAN2','ATAN2','CDABS','ABS'/
  103.  
  104.         DATA IFTYPE/3*8,2*1,2*2,
  105.      +2*8,1,34*8/
  106.  
  107.         SYMPTR=0
  108.  
  109.  100    IF (ZYGNSY(SYMPTR,SYMBOL).EQ.-100) RETURN
  110.         BITS=SYMBOL(6)
  111.         IF (SYMBOL(1).EQ.7 .AND.
  112.      +      ZIAND(BITS,4096).NE.0) THEN
  113.             CALL ZYGTST(SYMBOL(2),TEXT)
  114. C
  115. C Change it if it matches one of our list of non-generic functions
  116. C
  117.             CALL ZITOF(TEXT,1,6,SYMNAM,.FALSE.)
  118.             N=0
  119.  200        N=N+1
  120.             IF (N.LT.NCONVS .AND. SYMNAM.NE.IFNAME(1,N)) GOTO 200
  121.             IF (SYMNAM.EQ.IFNAME(1,N)) THEN
  122. C
  123. C Yes - change it unless ...
  124. C
  125.                 CALL ZFTOI(IFNAME(2,N),1,6,TEXT2,.FALSE.)
  126.                 CALL ZSTRIP(TEXT2)
  127.                 CHANGE=.TRUE.
  128. C ... It was explicitly typed
  129.                 IF (ZIAND(BITS,8).NE.0) THEN
  130.                     CALL PUTLIN(TEXT,2)
  131.                     CALL ZCHOUT(' n'//
  132.      +                          'ot changed due to explicit typing, in '
  133.      +                        ,2)
  134.                     CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
  135.                     CALL ZYGTST(SYMBOL(2),TEXT)
  136.                     CALL PUTLIN(TEXT,2)
  137.                     CALL PUTCH(10,2)
  138.                     CHANGE=.FALSE.
  139. C ... or it was used as an actual argument
  140.                 ELSE IF (ZIAND(BITS,2048).NE.0) THEN
  141.                     CALL PUTLIN(TEXT,2)
  142.                     CALL ZCHOUT(' used as actual argument - n'//
  143.      +                         'ot changed, in ',2)
  144.                     CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
  145.                     CALL ZYGTST(SYMBOL(2),TEXT)
  146.                     CALL PUTLIN(TEXT,2)
  147.                     CALL PUTCH(10,2)
  148.                     CHANGE=.FALSE.
  149. C ... or the resultant function name is already used as something else
  150.                 ELSE IF (ZYFSYM(TEXT2,SYMBOL(3),RESULT).NE.-1)
  151.      +              THEN
  152. C It is used - if it is not used as an intrinsic give an error
  153.                     IF (RESULT(1).NE.7 .OR.
  154.      +                  ZIAND(RESULT(6),4096).EQ.0
  155.      +                  .OR. RESULT(4).NE.IFTYPE(N)) THEN
  156.                         CALL ZCHOUT('Couldn''t use function ',2)
  157.                         CALL PUTLIN(TEXT2,2)
  158.                         CALL ZMESS(' due to name clash, in ',2)
  159.                         CALL ZYGTSY(ZYGPUS(SYMBOL(3)),SYMBOL)
  160.                         CALL ZYGTST(SYMBOL(2),TEXT)
  161.                         CALL PUTLIN(TEXT,2)
  162.                         CALL PUTCH(10,2)
  163.                         CHANGE=.FALSE.
  164.                     ELSE
  165.                         CALL ZCHOUT('Duplicate symbol "',2)
  166.                         CALL PUTLIN(TEXT2,2)
  167.                         CALL ZMESS('" produced - further analysis'//
  168.      +' must be preceded by YF a'//'nd YP',2)
  169.                     END IF
  170.                 END IF
  171.                 IF (CHANGE) THEN
  172.                     STRPTR=ZYASTR(TEXT2)
  173.                     CALL ZYSATT(SYMPTR,2,STRPTR)
  174.                     CALL ZYSATT(SYMPTR,4,IFTYPE(N))
  175.                 END IF
  176.             END IF
  177.         END IF
  178.         GO TO 100
  179.  
  180.         END
  181.